home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / Memtable.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  14.7 KB  |  562 lines

  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit MemTable;
  12.  
  13. {$I RX.INC}
  14. {$N+,P+,S-}
  15.  
  16. interface
  17.  
  18. uses SysUtils, Classes, Controls, {$IFDEF WIN32} Bde, {$ELSE} DbiTypes,
  19.   DbiProcs, DbiErrs, {$ENDIF} DB, DBTables;
  20.  
  21. type
  22.  
  23. { TMemoryTable }
  24.  
  25.   TMemoryTable = class(TDBDataSet)
  26.   private
  27.     FTableName: TFileName;
  28.     FMoveHandle: HDBICur;
  29.     FEnableDelete: Boolean;
  30.     FDisableEvents: Boolean;
  31.     procedure EncodeFieldDesc(var FieldDesc: FLDDesc;
  32.       const Name: string; DataType: TFieldType; Size
  33.       {$IFDEF RX_D4}, Precision {$ENDIF}: Word);
  34.     procedure SetTableName(const Value: TFileName);
  35.     function SupportedFieldType(AType: TFieldType): Boolean;
  36.     procedure DeleteCurrentRecord;
  37.   protected
  38.     function CreateHandle: HDBICur; override;
  39.     procedure DoBeforeClose; override;
  40.     procedure DoAfterClose; override;
  41.     procedure DoBeforeOpen; override;
  42.     procedure DoAfterOpen; override;
  43. {$IFDEF RX_D3}
  44.     procedure DoBeforeScroll; override;
  45.     procedure DoAfterScroll; override;
  46. {$ENDIF}
  47. {$IFDEF WIN32}
  48.     function GetRecordCount: {$IFNDEF RX_D3} Longint {$ELSE}
  49.       Integer; override {$ENDIF};
  50. {$ENDIF}
  51. {$IFDEF RX_D3}
  52.     function GetRecNo: Integer; override;
  53.     procedure SetRecNo(Value: Integer); override;
  54.     procedure InternalDelete; override;
  55. {$ELSE}
  56.     procedure DoBeforeDelete; override;
  57.     function GetRecordNumber: Longint; {$IFNDEF VER80} override; {$ENDIF}
  58.     procedure SetRecNo(Value: Longint);
  59. {$ENDIF}
  60.   public
  61.     constructor Create(AOwner: TComponent); override;
  62.     function BatchMove(ASource: TDataSet; AMode: TBatchMode;
  63.       ARecordCount: Longint): Longint;
  64.     procedure CopyStructure(ASource: TDataSet);
  65.     procedure CreateTable;
  66.     procedure DeleteTable;
  67.     procedure EmptyTable;
  68.     procedure GotoRecord(RecordNo: Longint);
  69. {$IFDEF RX_D3}
  70.     function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
  71.     function IsSequenced: Boolean; override;
  72.     function Locate(const KeyFields: string; const KeyValues: Variant;
  73.       Options: TLocateOptions): Boolean; override;
  74.     function Lookup(const KeyFields: string; const KeyValues: Variant;
  75.       const ResultFields: string): Variant; override;
  76. {$ENDIF}
  77.     procedure SetFieldValues(const FieldNames: array of string;
  78.       const Values: array of const);
  79. {$IFNDEF RX_D3}
  80. {$IFNDEF VER80}
  81.     property RecordCount: Longint read GetRecordCount;
  82. {$ENDIF}
  83. {$ENDIF}
  84. {$IFNDEF RX_D3}
  85.     property RecNo: Longint read GetRecordNumber write SetRecNo;
  86. {$ENDIF}
  87.   published
  88.     property EnableDelete: Boolean read FEnableDelete write FEnableDelete
  89.       default True;
  90.     property TableName: TFileName read FTableName write SetTableName;
  91.   end;
  92.  
  93. implementation
  94.  
  95. uses DBConsts, DBUtils, BdeUtils, {$IFDEF RX_D3} BDEConst, {$ENDIF} 
  96.   Forms, MaxMin;
  97.  
  98. { Memory tables are created in RAM and deleted when you close them. They
  99.   are much faster and are very useful when you need fast operations on
  100.   small tables. Memory tables do not support certain features (like
  101.   deleting records, referntial integrity, indexes, autoincrement fields
  102.   and BLOBs) }
  103.  
  104. { TMemoryTable }
  105.  
  106. constructor TMemoryTable.Create(AOwner: TComponent);
  107. begin
  108.   inherited Create(AOwner);
  109.   FEnableDelete := True;
  110. end;
  111.  
  112. function TMemoryTable.BatchMove(ASource: TDataSet; AMode: TBatchMode;
  113.   ARecordCount: Longint): Longint;
  114. var
  115.   SourceActive: Boolean;
  116.   MovedCount: Longint;
  117. begin
  118.   if (ASource = nil) or (Self = ASource) or
  119.     not (AMode in [batCopy, batAppend]) then _DBError(SInvalidBatchMove);
  120.   SourceActive := ASource.Active;
  121.   try
  122.     ASource.DisableControls;
  123.     DisableControls;
  124.     ASource.Open;
  125.     ASource.CheckBrowseMode;
  126.     ASource.UpdateCursorPos;
  127.     if AMode = batCopy then begin
  128.       Close;
  129.       CopyStructure(ASource);
  130.     end;
  131.     if not Active then Open;
  132.     CheckBrowseMode;
  133.     if ARecordCount > 0 then begin
  134.       ASource.UpdateCursorPos;
  135.       MovedCount := ARecordCount;
  136.     end
  137.     else begin
  138.       ASource.First;
  139.       MovedCount := MaxLongint;
  140.     end;
  141.     try
  142.       Result := 0;
  143.       while not ASource.EOF do begin
  144.         Append;
  145.         AssignRecord(ASource, Self, True);
  146.         Post;
  147.         Inc(Result);
  148.         if Result >= MovedCount then Break;
  149.         ASource.Next;
  150.       end;
  151.     finally
  152.       Self.First;
  153.     end;
  154.   finally
  155.     if not SourceActive then ASource.Close;
  156.     Self.EnableControls;
  157.     ASource.EnableControls;
  158.   end;
  159. end;
  160.  
  161. procedure TMemoryTable.CopyStructure(ASource: TDataSet);
  162.  
  163.   procedure CreateField(FieldDef: TFieldDef; AOwner: TComponent);
  164.   begin
  165. {$IFDEF RX_D4}
  166.     FieldDef.CreateField(AOwner, nil, FieldDef.Name, True);
  167. {$ELSE}
  168.     FieldDef.CreateField(AOwner);
  169. {$ENDIF}
  170.   end;
  171.  
  172. var
  173.   I: Integer;
  174. begin
  175.   CheckInactive;
  176.   for I := FieldCount - 1 downto 0 do Fields[I].Free;
  177.   if (ASource = nil) then Exit;
  178.   ASource.FieldDefs.Update;
  179.   FieldDefs := ASource.FieldDefs;
  180.   for I := 0 to FieldDefs.Count - 1 do begin
  181.     if SupportedFieldType(FieldDefs.Items[I].DataType) then begin
  182.       if (csDesigning in ComponentState) and (Owner <> nil) then
  183.         CreateField(FieldDefs.Items[I], Owner)
  184.       else
  185.         CreateField(FieldDefs.Items[I], Self);
  186.     end;
  187.   end;
  188. end;
  189.  
  190. procedure TMemoryTable.DeleteCurrentRecord;
  191. var
  192.   CurRecNo, CurRec: Longint;
  193.   Buffer: Pointer;
  194.   iFldCount: Word;
  195.   FieldDescs: PFLDDesc;
  196. begin
  197.   CurRecNo := RecNo;
  198.   iFldCount := FieldDefs.Count;
  199.   FieldDescs := AllocMem(iFldCount * SizeOf(FLDDesc));
  200.   try
  201.     Check(DbiGetFieldDescs(Handle, FieldDescs));
  202.     Check(DbiCreateInMemTable(DBHandle, '$InMem$', iFldCount, FieldDescs,
  203.       FMoveHandle));
  204.     try
  205.       DisableControls;
  206.       Buffer := AllocMem(RecordSize);
  207.       try
  208.         First;
  209.         CurRec := 0;
  210.         while not Self.EOF do begin
  211.           Inc(CurRec);
  212.           if CurRec <> CurRecNo then begin
  213.             DbiInitRecord(FMoveHandle, Buffer);
  214.             Self.GetCurrentRecord(Buffer);
  215.             Check(DbiAppendRecord(FMoveHandle, Buffer));
  216.           end;
  217.           Self.Next;
  218.         end;
  219.         FDisableEvents := True;
  220.         try
  221.           Close;
  222.           Open;
  223.           FMoveHandle := nil;
  224.         finally
  225.           FDisableEvents := False;
  226.         end;
  227.       finally
  228.         FreeMem(Buffer, RecordSize);
  229.       end;
  230.     except
  231.       DbiCloseCursor(FMoveHandle);
  232.       FMoveHandle := nil;
  233.       raise;
  234.     end;
  235.     GotoRecord(CurRecNo - 1);
  236.   finally
  237.     if FieldDescs <> nil then
  238.       FreeMem(FieldDescs, iFldCount * SizeOf(FLDDesc));
  239.     FMoveHandle := nil;
  240.     EnableControls;
  241.   end;
  242. end;
  243.  
  244. {$IFDEF RX_D3}
  245.  
  246. function TMemoryTable.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
  247. var
  248.   IsBlank: LongBool;
  249.   RecBuf: PChar;
  250. begin
  251.   Result := inherited GetFieldData(Field, Buffer);
  252.   if not Result then begin
  253.     RecBuf := nil;
  254.     case State of
  255.       dsBrowse: if not IsEmpty then RecBuf := ActiveBuffer;
  256.       dsEdit, dsInsert: RecBuf := ActiveBuffer;
  257.       dsCalcFields: RecBuf := CalcBuffer;
  258.     end;
  259.     if RecBuf = nil then Exit;
  260.     with Field do
  261.       if (FieldNo > 0) then begin
  262.         Check(DbiGetField(Handle, FieldNo, RecBuf, nil, IsBlank));
  263.         Result := not IsBlank;
  264.       end;
  265.   end;
  266. end;
  267.  
  268. procedure TMemoryTable.InternalDelete;
  269. begin
  270.   if EnableDelete then DeleteCurrentRecord
  271.   else inherited;
  272. end;
  273.  
  274. function TMemoryTable.Locate(const KeyFields: string;
  275.   const KeyValues: Variant; Options: TLocateOptions): Boolean;
  276. begin
  277.   DoBeforeScroll;
  278.   Result := DataSetLocateThrough(Self, KeyFields, KeyValues, Options);
  279.   if Result then begin
  280.     DataEvent(deDataSetChange, 0);
  281.     DoAfterScroll;
  282.   end;
  283. end;
  284.  
  285. function TMemoryTable.Lookup(const KeyFields: string; const KeyValues: Variant;
  286.   const ResultFields: string): Variant;
  287. begin
  288.   Result := False;
  289. end;
  290.  
  291. {$ELSE}
  292.  
  293. procedure TMemoryTable.DoBeforeDelete;
  294. begin
  295.   inherited DoBeforeDelete;
  296.   if EnableDelete then begin
  297.     DeleteCurrentRecord;
  298.     DoAfterDelete;
  299.     SysUtils.Abort;
  300.   end;
  301. end;
  302.  
  303. {$ENDIF}
  304.  
  305. procedure TMemoryTable.DoAfterClose;
  306. begin
  307.   if not FDisableEvents then inherited DoAfterClose;
  308. end;
  309.  
  310. procedure TMemoryTable.DoAfterOpen;
  311. begin
  312.   if not FDisableEvents then inherited DoAfterOpen;
  313. end;
  314.  
  315. procedure TMemoryTable.DoBeforeClose;
  316. begin
  317.   if not FDisableEvents then inherited DoBeforeClose;
  318. end;
  319.  
  320. procedure TMemoryTable.DoBeforeOpen;
  321. begin
  322.   if not FDisableEvents then inherited DoBeforeOpen;
  323. end;
  324.  
  325. {$IFDEF RX_D3}
  326.  
  327. procedure TMemoryTable.DoBeforeScroll;
  328. begin
  329.   if not FDisableEvents then inherited DoBeforeScroll;
  330. end;
  331.  
  332. procedure TMemoryTable.DoAfterScroll;
  333. begin
  334.   if not FDisableEvents then inherited DoAfterScroll;
  335. end;
  336.  
  337. {$ENDIF}
  338.  
  339. function TMemoryTable.SupportedFieldType(AType: TFieldType): Boolean;
  340. begin
  341.   Result := not (AType in [ftUnknown {$IFDEF RX_D4}, ftWideString {$ENDIF}
  342.     {$IFDEF RX_D5}, ftOraBlob, ftOraClob, ftVariant, ftInterface, 
  343.     ftIDispatch, ftGuid {$ENDIF}] + ftNonTextTypes);
  344. end;
  345.  
  346. function TMemoryTable.CreateHandle: HDBICur;
  347. var
  348.   I: Integer;
  349. {$IFDEF RX_D4}
  350.   FldDescList: TFieldDescList;
  351.   FieldDescs: PFLDDesc;
  352. {$ELSE}
  353.   FieldDescs: PFLDDesc;
  354. {$ENDIF}
  355.   iFldCount: Cardinal;
  356.   szTblName: DBITBLNAME;
  357. begin
  358.   if (FMoveHandle <> nil) then begin
  359.     Result := FMoveHandle;
  360.     Exit;
  361.   end;
  362.   if FieldCount > 0 then FieldDefs.Clear;
  363.   if FieldDefs.Count = 0 then
  364.     for I := 0 to FieldCount - 1 do begin
  365.       if not SupportedFieldType(Fields[I].DataType) then
  366. {$IFDEF RX_D3}
  367.  {$IFDEF RX_D4}
  368.         DatabaseErrorFmt(SUnknownFieldType, [Fields[I].FieldName]);
  369.  {$ELSE}
  370.         DatabaseErrorFmt(SFieldUnsupportedType, [Fields[I].FieldName]);
  371.  {$ENDIF}
  372. {$ELSE}
  373.         DBErrorFmt(SFieldUnsupportedType, [Fields[I].FieldName]);
  374. {$ENDIF}
  375.       with Fields[I] do
  376.         if not (Calculated {$IFDEF WIN32} or Lookup {$ENDIF}) then
  377.           FieldDefs.Add(FieldName, DataType, Size, Required);
  378.     end;
  379. {$IFNDEF RX_D4}
  380.   FieldDescs := nil;
  381. {$ENDIF}
  382.   iFldCount := FieldDefs.Count;
  383.   SetDBFlag(dbfTable, True);
  384.   try
  385.     if TableName = '' then
  386.       AnsiToNative(Locale, '$RxInMem$', szTblName, SizeOf(szTblName) - 1)
  387.     else
  388.       AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
  389. {$IFDEF RX_D4}
  390.     SetLength(FldDescList, iFldCount);
  391.     FieldDescs := BDE.PFLDDesc(FldDescList);
  392. {$ELSE}
  393.     FieldDescs := AllocMem(iFldCount * SizeOf(FLDDesc));
  394. {$ENDIF}
  395.     for I := 0 to FieldDefs.Count - 1 do begin
  396.       with FieldDefs[I] do
  397. {$IFDEF RX_D4}
  398.         EncodeFieldDesc(FldDescList[I], Name, DataType, Size, Precision);
  399. {$ELSE}
  400.         EncodeFieldDesc(PFieldDescList(FieldDescs)^[I], Name, DataType, Size);
  401. {$ENDIF}
  402.     end;
  403.     Check(DbiTranslateRecordStructure(nil, iFldCount, FieldDescs, nil, nil,
  404.       FieldDescs {$IFDEF WIN32}, False {$ENDIF}));
  405.     Check(DbiCreateInMemTable(DBHandle, szTblName, iFldCount, FieldDescs,
  406.       Result));
  407.   finally
  408. {$IFNDEF RX_D4}
  409.     if FieldDescs <> nil then FreeMem(FieldDescs, iFldCount * SizeOf(FLDDesc));
  410. {$ENDIF}
  411.     SetDBFlag(dbfTable, False);
  412.   end;
  413. end;
  414.  
  415. procedure TMemoryTable.CreateTable;
  416. begin
  417.   CheckInactive;
  418.   Open;
  419. end;
  420.  
  421. procedure TMemoryTable.DeleteTable;
  422. begin
  423.   CheckBrowseMode;
  424.   Close;
  425. end;
  426.  
  427. procedure TMemoryTable.EmptyTable;
  428. begin
  429.   if Active then begin
  430.     CheckBrowseMode;
  431.     DisableControls;
  432.     FDisableEvents := True;
  433.     try
  434.       Close;
  435.       Open;
  436.     finally
  437.       FDisableEvents := False;
  438.       EnableControls;
  439.     end;
  440.   end;
  441. end;
  442.  
  443. procedure TMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc;
  444.   const Name: string; DataType: TFieldType; Size
  445.   {$IFDEF RX_D4}, Precision {$ENDIF}: Word);
  446. begin
  447.   with FieldDesc do begin
  448.     FillChar(szName, SizeOf(szName), 0);
  449.     AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
  450.     iFldType := FieldLogicMap(DataType);
  451.     iSubType := FieldSubtypeMap(DataType);
  452. {$IFDEF WIN32}
  453.     if iSubType = fldstAUTOINC then iSubType := 0;
  454. {$ENDIF WIN32}
  455.     case DataType of
  456. {$IFDEF RX_D4}
  457.       ftString, ftFixedChar, ftBytes, ftVarBytes, ftBlob..ftTypedBinary:
  458. {$ELSE}
  459.       ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic
  460.       {$IFDEF WIN32}, ftFmtMemo, ftParadoxOle, ftDBaseOle,
  461.       ftTypedBinary {$ENDIF}:
  462. {$ENDIF}
  463.         iUnits1 := Size;
  464.       ftBCD:
  465.         begin
  466. {$IFDEF RX_D4}
  467.           { Default precision is 32, Size = Scale }
  468.           if (Precision > 0) and (Precision <= 32) then iUnits1 := Precision
  469.           else iUnits1 := 32;
  470. {$ELSE}
  471.           iUnits1 := 32;
  472. {$ENDIF}
  473.           iUnits2 := Size;  {Scale}
  474.         end;
  475.     end;
  476.   end;
  477. end;
  478.  
  479. {$IFDEF WIN32}
  480. function TMemoryTable.GetRecordCount: {$IFNDEF RX_D3} Longint {$ELSE} Integer {$ENDIF};
  481. begin
  482.   if State = dsInactive then _DBError(SDataSetClosed);
  483.   Check(DbiGetRecordCount(Handle, Result));
  484. end;
  485. {$ENDIF WIN32}
  486.  
  487. procedure TMemoryTable.SetRecNo(Value: {$IFDEF RX_D3} Integer {$ELSE} Longint {$ENDIF});
  488. var
  489.   Rslt: DBIResult;
  490. begin
  491.   CheckBrowseMode;
  492.   UpdateCursorPos;
  493.   Rslt := DbiSetToSeqNo(Handle, Value);
  494.   if Rslt = DBIERR_EOF then Last
  495.   else if Rslt = DBIERR_BOF then First
  496.   else begin
  497.     Check(Rslt);
  498.     Resync([rmExact, rmCenter]);
  499.   end;
  500. end;
  501.  
  502. {$IFDEF RX_D3}
  503. function TMemoryTable.GetRecNo: Integer;
  504. {$ELSE}
  505. function TMemoryTable.GetRecordNumber: Longint;
  506. {$ENDIF}
  507. var
  508.   Rslt: DBIResult;
  509. begin
  510.   Result := -1;
  511.   if State in [dsBrowse, dsEdit] then begin
  512.     UpdateCursorPos;
  513.     Rslt := DbiGetSeqNo(Handle, Result);
  514.     if (Rslt = DBIERR_EOF) or (Rslt = DBIERR_BOF) then Exit
  515.     else Check(Rslt);
  516.   end;
  517. end;
  518.  
  519. procedure TMemoryTable.GotoRecord(RecordNo: Longint);
  520. begin
  521.   RecNo := RecordNo;
  522. end;
  523.  
  524. {$IFDEF RX_D3}
  525. function TMemoryTable.IsSequenced: Boolean;
  526. begin
  527.   Result := not Filtered;
  528. end;
  529. {$ENDIF RX_D3}
  530.  
  531. procedure TMemoryTable.SetFieldValues(const FieldNames: array of string;
  532.   const Values: array of const);
  533. var
  534.   I: Integer;
  535.   Pos: Longint;
  536. begin
  537.   Pos := RecNo;
  538.   DisableControls;
  539.   try
  540.     First;
  541.     while not EOF do begin
  542.       Edit;
  543.       for I := 0 to Max(High(FieldNames), High(Values)) do
  544.         FieldByName(FieldNames[I]).AssignValue(Values[I]);
  545.       Post;
  546.       Next;
  547.     end;
  548.     GotoRecord(Pos);
  549.   finally
  550.     EnableControls;
  551.   end;
  552. end;
  553.  
  554. procedure TMemoryTable.SetTableName(const Value: TFileName);
  555. begin
  556.   CheckInactive;
  557.   FTableName := Value;
  558.   DataEvent(dePropertyChange, 0);
  559. end;
  560.  
  561. end.
  562.